home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / guile-ii.src / guile-ii / guile-src / libguile / continuations.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-06-13  |  5.3 KB  |  203 lines
  1. /*    Copyright (C) 1995 Free Software Foundation, Inc.
  2.  * 
  3.  * This program is free software; you can redistribute it and/or modify
  4.  * it under the terms of the GNU General Public License as published by
  5.  * the Free Software Foundation; either version 2, or (at your option)
  6.  * any later version.
  7.  * 
  8.  * This program is distributed in the hope that it will be useful,
  9.  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  10.  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11.  * GNU General Public License for more details.
  12.  * 
  13.  * You should have received a copy of the GNU General Public License
  14.  * along with this software; see the file COPYING.  If not, write to
  15.  * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  16.  *
  17.  * As a special exception, the Free Software Foundation gives permission
  18.  * for additional uses of the text contained in its release of GUILE.
  19.  *
  20.  * The exception is that, if you link the GUILE library with other files
  21.  * to produce an executable, this does not by itself cause the
  22.  * resulting executable to be covered by the GNU General Public License.
  23.  * Your use of that executable is in no way restricted on account of
  24.  * linking the GUILE library code into it.
  25.  *
  26.  * This exception does not however invalidate any other reasons why
  27.  * the executable file might be covered by the GNU General Public License.
  28.  *
  29.  * This exception applies only to the code released by the
  30.  * Free Software Foundation under the name GUILE.  If you copy
  31.  * code from other Free Software Foundation releases into a copy of
  32.  * GUILE, as the General Public License permits, the exception does
  33.  * not apply to the code that you add in this way.  To avoid misleading
  34.  * anyone as to the status of such modified files, you must delete
  35.  * this exception notice from them.
  36.  *
  37.  * If you write modifications of your own for GUILE, it is your choice
  38.  * whether to permit this exception to apply to your modifications.
  39.  * If you do not wish that, delete this exception notice.  
  40.  */
  41.  
  42.  
  43. #include <stdio.h>
  44. #include "_scm.h"
  45.  
  46.  
  47.  
  48. /* {Continuations}
  49.  */
  50.  
  51. SCM scm_throwval = SCM_UNDEFINED;
  52.  
  53. static char s_cont[] = "continuation";
  54.  
  55. #ifdef __STDC__
  56. SCM 
  57. scm_make_cont (void)
  58. #else
  59. SCM 
  60. scm_make_cont ()
  61. #endif
  62. {
  63.   long j;
  64.   SCM cont;
  65. #ifdef CHEAP_CONTINUATIONS
  66.   NEWCELL (cont);
  67.   DEFER_INTS;
  68.   SETJMPBUF (cont, scm_must_malloc ((long) sizeof (regs), s_cont));
  69.   CAR (cont) = tc7_contin;
  70.   DYNENV (cont) = dynwinds;
  71.   BASE (cont) = BASE (rootcont);
  72.   SEQ (cont) = SEQ (rootcont);
  73.   ALLOW_INTS;
  74. #else
  75.   register STACKITEM *src, *dst;
  76.   NEWCELL (cont);
  77.   DEFER_INTS;
  78.   FLUSH_REGISTER_WINDOWS;
  79.   j = scm_stack_size (BASE (rootcont));
  80.   SETJMPBUF (cont,
  81.          scm_must_malloc ((long) (sizeof (regs) + j * sizeof (STACKITEM)),
  82.                   s_cont));
  83.   SETLENGTH (cont, j, tc7_contin);
  84.   DYNENV (cont) = dynwinds;
  85.   src = BASE (cont) = BASE (rootcont);
  86.   SEQ (cont) = SEQ (rootcont);
  87.   ALLOW_INTS;
  88. #ifndef STACK_GROWS_UP
  89.   src -= LENGTH (cont);
  90. #endif /* ndef STACK_GROWS_UP */
  91.   dst = (STACKITEM *) (CHARS (cont) + sizeof (regs));
  92.   for (j = LENGTH (cont); 0 <= --j;)
  93.     *dst++ = *src++;
  94. #endif /* def CHEAP_CONTINUATIONS */
  95.   return cont;
  96. }
  97.  
  98.  
  99. void scm_dynthrow P ((SCM *a));
  100.  
  101. /* Grow the stack so that there is room */
  102. /* to copy in the continuation.  Then */
  103. #ifndef CHEAP_CONTINUATIONS
  104. #ifdef __STDC__
  105. static void 
  106. grow_throw (SCM *a)
  107. #else
  108. static void 
  109. grow_throw (a)
  110.      SCM *a;
  111. #endif
  112. {                /* retry the throw. */
  113.   SCM growth[100];
  114.   growth[0] = a[0];
  115.   growth[1] = a[1];
  116.   growth[2] = a[2] + 1;
  117.   growth[3] = (SCM) a;
  118.   scm_dynthrow (growth);
  119. }
  120. #endif /* ndef CHEAP_CONTINUATIONS */
  121.  
  122. #ifdef __STDC__
  123. void 
  124. scm_dynthrow (SCM *a)
  125. #else
  126. void 
  127. scm_dynthrow (a)
  128.      SCM *a;
  129. #endif
  130. {
  131.   SCM cont = a[0], val = a[1];
  132. #ifndef CHEAP_CONTINUATIONS
  133.   register long j;
  134.   register STACKITEM *src, *dst = BASE (rootcont);
  135. #ifdef STACK_GROWS_UP
  136.   if (a[2] && (a - ((SCM *) a[3]) < 100))
  137. #else
  138.   if (a[2] && (((SCM *) a[3]) - a < 100))
  139. #endif
  140.     fputs ("grow_throw: check if SCM growth[100]; being optimized out\n",
  141.        stderr);
  142.   /* if (a[2]) fprintf(stderr, " ct = %ld, dist = %ld\n",
  143.               a[2], (((SCM *)a[3]) - a)); */
  144. #ifdef STACK_GROWS_UP
  145.   if (PTR_GE (dst + LENGTH (cont), (STACKITEM *) & a))
  146.     grow_throw (a);
  147. #else
  148.   dst -= LENGTH (cont);
  149.   if (PTR_LE (dst, (STACKITEM *) & a))
  150.     grow_throw (a);
  151. #endif /* def STACK_GROWS_UP */
  152.   FLUSH_REGISTER_WINDOWS;
  153.   src = (STACKITEM *) (CHARS (cont) + sizeof (regs));
  154.   for (j = LENGTH (cont); 0 <= --j;)
  155.     *dst++ = *src++;
  156. #ifdef sparc            /* clear out stack up to this stackframe */
  157.   /* maybe this would help, maybe not */
  158. /*    bzero((void *)&a, sizeof(STACKITEM) * (((STACKITEM *)&a) -
  159.                            (dst - LENGTH(cont)))) */
  160. #endif
  161. #endif /* ndef CHEAP_CONTINUATIONS */
  162.   scm_throwval = val;
  163.   longjmp (JMPBUF (cont), 1);
  164. }
  165.  
  166. #ifdef __STDC__
  167. SCM
  168. scm_throw (SCM cont, SCM val)
  169. #else
  170. SCM
  171. scm_throw (cont, val)
  172.      SCM cont;
  173.      SCM val;
  174. #endif
  175. {
  176.   SCM a[3];
  177.   a[0] = cont;
  178.   a[1] = val;
  179.   a[2] = 0;
  180.   if (   (SEQ (cont) != SEQ (rootcont))
  181.       || (BASE (cont) != BASE (rootcont)))  /* base compare not needed */
  182.     scm_wta (cont, "continuation from wrong top level", s_cont);
  183.   
  184.   scm_dowinds (DYNENV (cont),
  185.            scm_ilength (dynwinds) - scm_ilength (DYNENV (cont)));
  186.   
  187.   scm_dynthrow (a);
  188.   return UNSPECIFIED; /* not reached */
  189. }
  190.  
  191.  
  192. #ifdef __STDC__
  193. void
  194. scm_init_continuations (void)
  195. #else
  196. void
  197. scm_init_continuations ()
  198. #endif
  199. {
  200. #include "continuations.x"
  201. }
  202.  
  203.